Mac Easy 2010 May/Mac Life Ubuntu.iso/casper/filesystem.squashfs/usr/share/guile/1.8/ice-9/gds-server.scm

Text File | 2008-12-17 | 7.1 KB | 194 lines

;;;; Guile Debugger UI server

;;; Copyright (C) 2003 Free Software Foundation, Inc.
;;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2.1 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

(define-module (ice-9 gds-server)
  #:export (run-server))

;; UI is normally via a pipe to Emacs, so make sure to flush output
;; every time we write.
(define (write-to-ui form)
  (write form)
  (newline)
  (force-output))

(define (trc . args)
  (write-to-ui (cons '* args)))

(define (with-error->eof proc port)
  (catch #t
     (lambda () (proc port))
     (lambda args the-eof-object)))

(define connection->id (make-object-property))

(define (run-server port-or-path)

  (or (integer? port-or-path)
      (string? port-or-path)
      (error "port-or-path should be an integer (port number) or a string (file name)"
         port-or-path))

  (let ((server (socket (if (integer? port-or-path) PF_INET PF_UNIX)
            SOCK_STREAM
            0)))

    ;; Initialize server socket.
    (if (integer? port-or-path)
    (begin
      (setsockopt server SOL_SOCKET SO_REUSEADDR 1)
      (bind server AF_INET INADDR_ANY port-or-path))
    (begin
      (catch #t
         (lambda () (delete-file port-or-path))
         (lambda _ #f))
      (bind server AF_UNIX port-or-path)))

    ;; Start listening.
    (listen server 5)

    (let loop ((clients '()) (readable-sockets '()))

      (define (do-read port)
    (cond ((eq? port (current-input-port))
           (do-read-from-ui))
          ((eq? port server)
           (accept-new-client))
          (else
           (do-read-from-client port))))

      (define (do-read-from-ui)
    (trc "reading from ui")
    (let* ((form (with-error->eof read (current-input-port)))
           (client (assq-ref (map (lambda (port)
                    (cons (connection->id port) port))
                      clients)
                 (car form))))
      (with-error->eof read-char (current-input-port))
      (if client
          (begin
        (write (cdr form) client)
        (newline client))
          (trc "client not found")))
    clients)

      (define (accept-new-client)
        (let ((new-port (car (accept server))))
      ;; Read the client's ID.
      (let ((name-form (read new-port)))
        ;; Absorb the following newline character.
        (read-char new-port)
        ;; Check that we have a name form.
        (or (eq? (car name-form) 'name)
        (error "Invalid name form:" name-form))
        ;; Store an association from the connection to the ID.
        (set! (connection->id new-port) (cadr name-form))
        ;; Pass the name form on to Emacs.
        (write-to-ui (cons (connection->id new-port) name-form)))
      ;; Add the new connection to the set that we select on.
          (cons new-port clients)))

      (define (do-read-from-client port)
    (trc "reading from client")
    (let ((next-char (with-error->eof peek-char port)))
      ;;(trc 'next-char next-char)
      (cond ((eof-object? next-char)
         (write-to-ui (list (connection->id port) 'closed))
         (close port)
         (delq port clients))
        ((char=? next-char #\()
         (write-to-ui (cons (connection->id port)
                    (with-error->eof read port)))
         clients)
        (else
         (with-error->eof read-char port)
         clients))))

      ;;(trc 'clients clients)
      ;;(trc 'readable-sockets readable-sockets)

      (if (null? readable-sockets)
      (loop clients (car (select (cons (current-input-port)
                       (cons server clients))
                     '()
                     '())))
      (loop (do-read (car readable-sockets)) (cdr readable-sockets))))))

;; What happens if there are multiple copies of Emacs running on the
;; same machine, and they all try to start up the GDS server?  They
;; can't all listen on the same TCP port, so the short answer is that
;; all of them except the first will get an EADDRINUSE error when
;; trying to bind.
;;
;; We want to be able to handle this scenario, though, so that Scheme
;; code can be evaluated, and help invoked, in any of those Emacsen.
;; So we introduce the idea of a "slave server".  When a new GDS
;; server gets an EADDRINUSE bind error, the implication is that there
;; is already a GDS server running, so the new server instead connects
;; to the existing one (by issuing a connect to the GDS port number).
;;
;; Let's call the first server the "master", and the new one the
;; "slave".  In principle the master can now proxy any GDS client
;; connections through to the slave, so long as there is sufficient
;; information in the protocol for it to decide when and how to do
;; this.
;;
;; The basic information and mechanism that we need for this is as
;; follows.
;;
;; - A unique ID for each Emacs; this can be each Emacs's PID.  When a
;; slave server connects to the master, it announces itself by sending
;; the protocol (emacs ID).
;;
;; - A way for a client to indicate which Emacs it wants to use.  At
;; the protocol level, this is an extra argument in the (name ...)
;; protocol.  (The absence of this argument means "no preference".  A
;; simplistic master server might then decide to use its own Emacs; a
;; cleverer one might monitor which Emacs appears to be most in use,
;; and use that one.)  At the API level this can be an optional
;; argument to the `gds-connect' procedure, and the Emacs GDS code
;; would obviously set this argument when starting a client from
;; within Emacs.
;;
;; We also want a strategy for continuing seamlessly if the master
;; server shuts down.
;;
;; - Each slave server will detect this as an error on the connection
;; to the master socket.  Each server then tries to bind to the GDS
;; port again (a race which the OS will resolve), and if that fails,
;; connect again.  The result of this is that there should be a new
;; master, and the others all slaves connected to the new master.
;;
;; - Each client will also detect this as an error on the connection
;; to the (master) server.  Either the client should try to connect
;; again (perhaps after a short delay), or the reconnection can be
;; delayed until the next time that the client requires the server.
;; (Probably the latter, all done within `gds-read'.)
;;
;; (Historical note: Before this master-slave idea, clients were
;; identified within gds-server.scm and gds*.el by an ID which was
;; actually the file descriptor of their connection to the server.
;; That is no good in the new scheme, because each client's ID must
;; persist when the master server changes, so we now use the client's
;; PID instead.  We didn't use PID before because the client/server
;; code was written to be completely asynchronous, which made it
;; tricky for the server to discover each client's PID and associate
;; it with a particular connection.  Now we solve that problem by
;; handling the initial protocol exchange synchronously.)
(define (run-slave-server port)
  'not-implemented)